perm filename 12T.F4[12,LCS]1 blob sn#089286 filedate 1974-03-03 generic text, type T, neo UTF8
00100	C **********  MATRIX  FEB. 16,73 ******** PRINTS 12-TONE CHART ******
00200	C  'S'EARCH WILL LOCATE ROW SOURCES OF CHORDS, ETC.
00300		COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
00400		1 INP2(72),INP(72),NRW
00500		1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
00600		DATA ISCAL/'C','C#','D','D#','E','F','F#','G','G#',
00700		1 'A','A#','B'/,INV/'I0','I1','I2','I3','I4','I5','I6','I7',
00800		1 'I8','I9','I10','I11'/,IR/'P0','P1','P2','P3','P4',
00900		1 'P5','P6','P7','P8','P9','P10','P11'/
01100		DATA IS2/'C','$','D','$','E','F','$','G','$','A','$','B'/
01110	C  N=NEW ROW, T=TYPE MATRIX, L=LPT, S=SEARCH, R=READ FILE 'ROWS', W=WRITE
01200	662	TYPE 61
01300		ACCEPT 1,NRW
01400		IF(NRW.EQ.'L')GO TO 62
01500		IF(NRW.EQ.'T')GO TO 1188
01510		IF(NRW.NE.'R'.AND.NRW.NE.'W')GO TO 6620
01520		CALL RDWRT
01540	C  WE'VE JUST READ IN A ROW.
01600	6620	IF(NRW.NE.'S')GO TO 64
01700	663	TYPE 65
01800		GO TO 661
01900	65	FORMAT(' TYPE NOTES'/)
02000	61	FORMAT(/' N=NEW, T=TYPE MTRX, S=SRCH, R=RD, W=WRT, L=LST'/)
02100	300	FORMAT(' PRINT HOW MANY?'/)
02200	200	FORMAT(' TYPE NAME OF WORK'/)
02300	62	KREP=0
02500		TYPE 300
02600		ACCEPT 400,KREP
02700	1188	KREP=KREP-1
02900		JOUT=3
03000		IF(NRW.EQ.'T')JOUT=5
03100		GO TO 288
03200	64	HEX=-10
03400		J(2,1)=INV(1)
03500		J(1,2)=IR(1)
03530		IF(NRW.EQ.'R')GO TO 661
03560	  	TYPE 200
03600	  	ACCEPT 444,NAME
03700	188	TYPE 100
03800	661	JOUT=5
04100		FIRST=-1.
04150		IF(NRW.EQ.'R')GO TO 6650
04200	  	ACCEPT 1,INP2
04400		IF(NRW.EQ.'S')GO TO 498
04500	6650	DO 665 KGZ=1,72
04600	665	INP(KGZ)=INP2(KGZ)
04700		GO TO 198
05000	C   IF A 13TH NOTE IS ADDED, THEN NO PRINTOUT.
05100	C   TYPE 'S' TO SEARCH, 'SP' OUTPUTS TO LPT.
05300	498	K=0
05400		JS=0
05500		ISQ2=0
06100	298	K=K+1
06200		DID=0
06300		IF(K.GT.72)GO TO 8888
06400		L=INP2(K)
06500		IF(L.EQ.' ')GO TO 298
06600		DO 888 M=1,12
06700		  IF(L.NE.IS2(M))GO TO 888
06800		  LL=M
06900		  K=K+1
07000		  IF(INP2(K).EQ.'S')LL=M+1
07100		  IF(INP2(K).EQ.'F')LL=M-1
07200		  ISQ2=ISQ2+2**LL
07300	C   ASSIGNS # TO EACH NOTE
07400		  JS=JS+1
07500	C   JS IS # OF NOTES IN GROUP TO BE FOUND.
07600		  GO TO 298
07700	888	CONTINUE
07800	8888	IF(JS.EQ.0)CALL EXIT
07900	C   NO NOTES WERE GIVEN.
08000		IF(FIRST)LGRP=JS
08100		FIRST=0
08200	C  SAVE # OF NOTES TO BE FOUND.
08300		JGRP=JS-1
08400		DO 333 NN=1,2
08600		  DO 333 K=1,13
08700	C   '+JGRP' IS FOR WRAP-AROUND
08800		  JQ=2
08900	  	    DO 222 L=1,12
09000		    KQ=L
09100	C   SETS # OF 1ST NOTE OF FOUND GROUP.
09200		    LL=0
09300		      DO 223 KK=JQ,JQ+JGRP
09400		      NR=KK
09500		      NI=K
09600		      IF(NN.EQ.1)GO TO 223
09700		      NR=K
09800		      NI=KK
09900	223	      LL=LL+ISQ(NR,NI)
10000	2223	    IF(LL.EQ.ISQ2)GO TO 334
10100	222	    JQ=JQ+1
10200		  GO TO 333
10300	334	  NR=1
10400		IF(LGRP.NE.JS)TYPE 67,JS  
10500		LGRP=JS
10600	C   NN=1, R FORMS.   NN=2, I FORMS.
10700		  IF(NN.EQ.1)GO TO 2334
10800		  NI=1
10900		  NR=K
11000	C   K WILL BE 1ST NOTE OF GROUP IN ROW.
11100	2334	  WRITE(JOUT, 66),J(NR,NI),KQ
11200		DID=-1.
11300	333	CONTINUE
11400		IF(DID)GO TO 3333
11600		IF(JGRP.NE.1)GO TO 3334
11700	C  DON'T TRY AGAIN IF GROUP IS DOWN TO 2.
11800		TYPE 67,JGRP
11900		GO TO 3333
12000	3334	DO 398 K=72,1,-1
12100		  IF(INP2(K).EQ.' ')GO TO 398
12200	3398	  INP2(K)=' '
12300		  INP2(K-1)=' '
12400		  GO TO 498
12500	398	CONTINUE
12600	C  ABOVE SHORTENS GROUP BY ONE.
12700	3333	TYPE 60
12800		GO TO 662
12900	198  	JJ=1
13000		K=0
13100	98	K=K+1
13200		IF(K.GT.72)GO TO 9999
13300		L=INP(K)
13400		IF(L.EQ.' ')GO TO 98
13500		IF(JJ.EQ.14)GO TO 99
13600	C   ANYTHING TYPED AFTER 12 NOTES CAUSES 'NOPRIN'.
13700		DO 999 M=1,12
13800		  IF(L.NE.IS2(M))GO TO 999
13900		  LL=M
14000		  K=K+1
14100		  IF(INP(K).EQ.'S')LL=M+1
14200		  IF(INP(K).EQ.'F')LL=M-1
14300		  JA(JJ)=LL
14400	C   SAVES #S FOR NOTATION
14500		  JJ=JJ+1
14600		  J(JJ,2)=LL
14700		  ISQ(JJ,2)=2**LL
14800	C   SETS VALUE AS POWER OF 2 FOR EACH NOTE.
14900		  GO TO 98
15000	999	CONTINUE
15200	99	CONTINUE
15300	
15400	9999	IF(JJ.EQ.1)CALL EXIT
15500	C   NO NOTES WERE GIVEN.
15600	    	I=J(2,2)
15700	C   WORKS OUT MATRIX
15800		DO 9 K=3,13
15900		  LL=J(K,2)-I+1
16000		  IF(LL.LE.0)LL=LL+12
16100	9	J(K,1)=INV(LL)
16200		DO 2 K=2,12
16300	2	N(K)=J(K+1,2)-I
16400		DO 3 K=3,13
16500		  LL=I-N(K-1)
16600		  IF(LL.LT.1)LL=LL+12
16700		  IF(LL.GT.12)LL=LL-12
16800		  ISQ(2,K)=2**LL
16900		  J(2,K)=LL
17000		  LL=LL+1-I
17100		  IF(LL.LE.0)LL=LL+12
17200	3	J(1,K)=IR(LL)
17300		DO 4 K=3,13
17400		  DO 4 I=3,13
17500		    LL=J(2,I)+N(K-1)
17600		    IF(LL.LT.1)LL=LL+12
17700		    IF(LL.GT.12)LL=LL-12
17800		    ISQ(K,I)=2**LL
17900	4	J(K,I)=ISCAL(LL)
18000		DO 7 K=2,13
18100	7	J(K,2)=ISCAL(J(K,2))
18200		DO 8 K=3,13
18300	8	J(2,K)=ISCAL(J(2,K))
18400	10	J(1,1)=0
18500		DO 28 K=2,13
18600		  DO 28 L=2,13
18700		    KQ=ISQ(K,L)
18800		    ISQ(K+12,L)=KQ
18900	28	ISQ(K,L+12)=KQ
19000	C   +12 FOR WRAP-AROUND
19200	288	WRITE(JOUT, 60),NAME
19300		WRITE(JOUT, 60)
19400	C  NEXT JUMPS OVER NOTATION PRINT.
19500		GO TO 5557
19600	C  UNTIL 210, PRINTS NOTATION
19700		G=' '
19800		WRITE(JOUT, 201),G
19900		L=5
20000		DO 202 IJ=1,7
20100		  LN=-1
20200		  IF(IJ.EQ.2.OR.IJ.EQ.4.OR.IJ.EQ.6)LN=0
20300	C   LINE OR SPACE
20400		JK=2
20500		IF(IJ.EQ.1.OR.IJ.EQ.4)JK=1
20600		  DO 203 IQ=1,JK
20700	204	    DO 205 K=1,49
20800	205	    INOT(K)=' '
20900		    DO 206 K=1,12
21000		      IF(JA(K).NE.L)GO TO 206
21100	C  SKIPS IF NO NOTE  NOW
21200		      IK=K
21300		      L=L-1
21400		      IF(L.EQ.0)L=12
21500		      M=K*4-1
21600		      IF(IK.GT.6)M=M+2
21700	2000	      INOT(M)='O'
21800		      IF(L.EQ.3.OR.L.EQ.1.OR.L.EQ.10.OR.L.EQ.8.OR.
21900		1     L.EQ.6)INOT(M-1)='#'
22000		      IF(L.EQ.2.OR.L.EQ.12.OR.L.EQ.9.OR.L.EQ.7.OR.
22100		1     L.EQ.5)LN=0
22200		      GO TO 208
22300	206	    CONTINUE
22400	208	    IF(LN)WRITE(JOUT, 209),(INOT(IZ),IZ=1,M)
22500	C   OVERPRINTS
22600	203	    IF(LN.EQ.0)WRITE(JOUT, 210),(INOT(IZ),IZ=1,M)
22700		  G=' '
22800		  IF(IJ.EQ.5)G='G'
22900	202	  IF(IJ.NE.2.AND.IJ.NE.4.AND.IJ.NE.6)WRITE(JOUT, 201),G
23000	201	FORMAT(2XA1,52('-'))
23100	209	FORMAT(4X49A1)
23200	210	FORMAT('+',4X49A1)
23300	C  PRINTS LINES FOR SCRATCH.
23400	
23500	5557	WRITE(JOUT, 60)
23600		J(1,1)='    '
23700		WRITE(JOUT, 5),J
23900	CC	IF(JOUT.EQ.5)PAUSE
24000	111	CONTINUE
24100		DO 1111 K=1,6
24200	1111	IC(K)=0
24300		LR=1
24400		JGRP=6
24500		KGRP=2
24600		MPRINT=2
24700				DO 1000 IGRP=1,4
24800		KK=0
24900		DO 17 K=1,12,JGRP
25000		  JJ=0
25100		  DO 117 L=1,JGRP
25200	117	  JJ=JJ+ISQ(K+L,2)
25300		KK=KK+1
25400	17	IC(KK)=JJ
25500		MM=0 
25600		MCNT=0
25700		DO 19 NN=1,2
25800		JQQ=4-NN
25900		DO 19 I=JQQ,13
26000		   DO 21 KK=1,KGRP
26100			DO 18 K=1,12,JGRP
26200			JJ=0
26300			  DO 118 L=1,JGRP
26400			  NI=I
26500			  NR=L+K
26600			  IF(NN.EQ.1)GO TO 118
26700			  NI=NR
26800			  NR=I
26900	118		  JJ=ISQ(NR,NI)+JJ
27000			LL=I
27100		        GO TO 18
27200		        WRITE(JOUT, 400),KK,JGRP,JJ,IGRP,KGRP,K
27300	18		IF(IC(KK).EQ.JJ)GO TO 21
27400		   GO TO 19
27500	21	   CONTINUE
27600		LI=LL
27700		LR=1
27800		IF(NN.EQ.1)GO TO 221
27900		LI=1
28000		LR=LL
28200	221	IF(MM)GO TO 55
28300		MPRINT=MPRINT+1
28400	C  COUNTS FOR STAFF PRINTOUT
28500		GO TO (11,22,33,44),IGRP
28600	11	WRITE(JOUT, 51)
28700		HEX=0
28800		GO TO 55
28900	22	WRITE(JOUT, 52)
29000		HEX=-10
29100		GO TO 55
29200	33	WRITE(JOUT, 53)
29300		HEX=-10
29400		GO TO 55
29500	44	WRITE(JOUT, 54)
29600		HEX=-10
29700	55	MM=-1
29900		IF(HEX.EQ.5)WRITE(JOUT, 51)
30000		HEX=HEX+1
30100		MCNT=MCNT+1
30200		WRITE(JOUT, 50),J(LR,LI)
30300		IF(MCNT.LT.7)GO TO 19
30400		MCNT=0
30500		MM=0
30600	C  TO STAY IN 8 1/2" WIDTH ON PAPER
30700	19	CONTINUE
30800		JGRP=JGRP-1
30900		IF(IGRP.EQ.1)JGRP=4
31000	1000			KGRP=12/JGRP
31100		KREP=KREP-1
31300		IF(JOUT.EQ.5)GO TO 662
31400		WRITE(JOUT, 60)
31500		L=5-MPRINT/2
31600		DO 5555 K=1,L
31700	5555	WRITE(JOUT, 5556)
31800		IF(KREP)CALL EXIT
31900		WRITE(JOUT, 500)
32000		GO TO 10
32100	5556	FORMAT(/5(1X,80('-')/)/)
32200	51	FORMAT(/' HEXADS ....P0',$)
32300	52	FORMAT(/' TETRADS ...P0',$)
32400	53	FORMAT(/' TRIADS ....P0',$)
32500	54	FORMAT(/' DYADS .....P0',$)
32600	5	FORMAT(1XA4,2(1X6A4)/2(/6(1XA4,2(1X6A4)/)))
32700	1	FORMAT (72A1)
32800	444	FORMAT (10A5)
32900	50	FORMAT('+  =  ',A3,$)
33000	60	FORMAT(1X10A5)
33100	66	FORMAT(1XA5,I2,3XI2)
33200	67	FORMAT(' GROUP SHORTENED TO ',I2)
33300	100	FORMAT(' TYPE 12 NOTES'/)
33400	500	FORMAT('1')
33500	400	FORMAT(6I)
33600		END